package provide direct 0.5
package require icq 0.8.8

namespace eval direct {
	namespace eval data {}
	variable version 8

	variable server_options { -uin -address -event }
	variable peer_options {-cookie -host -port -myport -uin -event
			-encoding -timeout}
	foreach x {away busy na dnd ffc} { lappend peer_options -auto-$x }
	array set codes {
		-1 Init
		 1 Ack
		 2 Message
		 3 Init2
	}
	variable base 0x67657268
	
	set text1 "As part of this software beta version Mirabilis is granting a limited access to the ICQ network, servers, directories, listings, information and databases (\"ICQ Services and Information\"). The ICQ Service and Information may databases (\"ICQ Services and Information\"). The ICQ Service and Information may\0"
	set text {As part of this software beta version Mirabilis is granting a limited access to the ICQ network, servers, directories, listings, information and databases ("ICQ Services and Information"). The ICQ Service and Information may}
	append text [string range $text end-79 end]
	binary scan $text1 c* textkey
	
	proc nc {args} { namespace code $args }

	# State of direct connection
	proc peer:state {var} {
		upvar 1 $var data
		set data(state)
	}
	# Clear message queue and return list of messaegs not sent
	proc peer:clear {var} {
		upvar 1 $var data
		set res $data(queue)
		set data(queue) [list]
		set res
	}

	# Send message
	proc peer:send {var type message} {
		upvar 1 $var data
		set id [::icq::msgid]
		lappend data(queue) [list $type $message $data(seq) $id]
		if {!$data(seq)} {set data(seq) 65535} else {incr data(seq) -1}
		event data Outgoing $type $message [clock seconds] $id
		if {$data(state)=="established"} { 
			after idle [nc peer:flush $var] 
		}
		set id
	}

	# Perform actual data flushing
	proc peer:flush {var} {
		upvar 1 $var data
		upvar 1 ${var}-sent sent
		if {![llength $data(queue)]} return
		foreach {type message seq id} [lindex $data(queue) 0] break
		send data [message $seq $data(-encoding) $message]
		set sent($seq) [list $type $message $id]
		set data(queue) [lrange $data(queue) 1 end]
		event data ACK sent $id
		after $data(-timeout) [nc CheckAck $var $seq]
		after idle [nc peer:flush $var]
	}
	
	# Attempt of direct connection
	proc peer:connect {var {proxy ""}} {
		upvar 1 $var data
		if {![info exists data(-port)]||![info exists data(-host)]} {
			return "Remote host and(or) port is not specified"
		}
		if { $data(state)=="established" } { return 1 }
		peer:disconnect data
		if {[catch { 
			set data(socket) [socket -async $data(-host) $data(-port)]
			}]} { return 0 } 
		fconfigure $data(socket) -translation binary -encoding binary\
				-blocking 0 -buffering none
		fileevent $data(socket) writable [nc Writable $var]
		array set data [list state "connecting" initiator 1]
		return 1
	}

	proc peer:disconnect {var {reason ""}} {
		upvar 1 $var data
		if {![info exists data(socket)]} return
		close $data(socket)
		unset data(socket)
		array set data [list state off initiator 0]
		event data Disconnected $reason
	}

	# Delete direct connection command
	proc peer:delete {var} {
		upvar 1 $var data
		peer:disconnect data
		interp alias {} [namespace tail $var] {}
		unset data
	}

	proc server:info {var} {
		upvar #0 $var data
		variable version
		list $data(port) $data(cookie) $version
	}
	proc server:delete {var} {
		upvar #0 $var data
		event data Log info "deleting server $var"
		if {[info exists data(socket)]} { close $data(socket) }
		unset data
		interp alias {} [namespace tail $var] {}
	}

	proc event {var event args} {
		upvar 1 $var data
		if {[catch { eval $data(-event)\
				[list $data(uin) $event] $args } r]} {
			puts stderr $r
		}
	}

}

proc direct::SpawnCommand {sock host port} {
	foreach {_ _ myport} [fconfigure $sock -sockname] break
	set var1 [namespace current]::data::server-$myport
	upvar #0 $var1 data
	# Make sure we have all needed parameters for peer
	if {![info exists data(-uin)] || ![info exists data(-event)]} {
		close $sock
		return
	}
	set var [namespace current]::data::tmp-$host:$port
	array set $var [list state connecting queue {} seq 65535 header 1\
		len 2 initiator 0 server $var1 socket $sock uin unknown\
		-event $data(-event) -uin $data(-uin)]
	fconfigure $sock -translation binary -encoding binary\
				-blocking 0 -buffering none
	fileevent $sock readable [nc Readable $var]
}

proc direct::PeekPeer {sock server uin cookie port} {
	set cmd peer-$uin
	upvar #0 $server srv
	if {$uin==$srv(-uin)} {
		peer:disconnect $server "Connections to own UIN are disabled"
		return
	}
	if {[info commands $cmd]!=$cmd} { 
		peer:disconnect $server "Uin $uin is not known, disconnecting"
		return
	}
	set var [namespace current]::data::$cmd
	if {[info exists ${var}(-cookie)]} {
		if {[set ${var}(-cookie)]!=$cookie} {
			event $var Log error "Cookie does not match for uin $uin, skipping"
			return ""
		}
	} else {
		event $var Log error "No cookie for uin $uin, skipping"
		return ""
	}
	array set $var [list socket $sock initiator 0 -port $port]
	fileevent $sock readable [nc Readable $var]
	set var
}

proc direct::Writable {var} {
	upvar #0 $var data
	
	fileevent $data(socket) writable {}
	fileevent $data(socket) readable [nc Readable $var]
	if {[catch { send data [Init $var]} reason]} {
		peer:disconnect data $reason
	}
	event data Connected
}

# Send data to var's socket
proc direct::send {var args} {
	upvar 1 $var data
	foreach packet $args {
		binary scan $packet H* hex
		event data Log {debug dump} "-> $hex"
		set packet [binary format sa* [string length $packet] $packet]
		if {[catch {
				puts -nonewline $data(socket) $packet
				flush $data(socket)
				} reason]} {
			peer:disconnect data $reason
		}
	}
}

proc direct::Readable {var} {
	upvar #0 ${var} data
	variable codes
	set reason "Connection closed by peer"
	if {[catch { set chunk [read $data(socket) $data(len)] } reason] ||
	    ![set length [string length $chunk]] && [eof $data(socket)]} {
		peer:disconnect data $reason
		return 
	}
	append data(packet) $chunk
	if {[incr data(len) -$length]} return

	# We got complete packet, parse it
	if {$data(header)} {
		binary scan $data(packet) s data(len)
	} else {
		binary scan $data(packet) H* hex
		event data Log {debug dump} "<- $hex"
		binary scan $data(packet) ca* id packet
		if {[info exists id] && [info exists codes($id)]} {
			set cmd incoming:$codes($id)
			if {[llength [info commands $cmd]]} {
				after idle [nc $cmd $var $packet $data(socket)]
			}
		}
		set data(len) 2
	}
	set data(header) [expr $data(header)^1]
	unset data(packet)
}

#proc direct::incoming:Ack {var packet sock} { send $sock [Ack] }

proc direct::incoming:Init {var packet sock} {
	binary scan $packet ssisiiIIcii ver _ me _ port he ip1 ip2 tcp\
		port2 cookie
	upvar #0 $var data
	event $var Log notice "Got Init"
	if {![info exists data(ver)] || $ver<$data(ver)} { set data(ver) $ver }
	if {$data(initiator)} {
		if {$data(ver)>6} { send data [Ack] [Init2 $var] }
	} else {
		if {$data(-uin)!=$me} {
			peer:disconnect data "Wrong credentials: $data(uin)!=$me $data(cookie)!=$cookie"
		} else {
			set var [PeekPeer $sock $data(server) $he $cookie $port]
			if {$var!=""} {
				send data [Ack] [Init $var] 
				unset data
			} else {
				event $var Log notice "Peer was not spawn"
			}
		}
	}
}

proc direct::incoming:Init2 {var packet sock} {
	upvar #0 $var data
	# If connection initiated by peer, check we got INIT before and
	# close connection otherwise
	if {!$data(initiator)} { 
		if {[info exists data(-cookie)]} {
			send data [Init2 $var 1]
		} else { close $sock }	
	}
	set data(state) established
	event $var Established
	peer:flush $var
}

proc direct::IP {ip} { 
	binary scan [binary format c4 [split $ip .]] I var 
	set var
}
proc direct::Dots {ip} {
	binary scan [binary format I $ip] c4 tmp
	foreach x $tmp { lappend res [expr ($x+0x100)%0x100] }
	join $res .
}

proc direct::Init {var} {
	upvar 1 $var data
	variable version
	foreach {addr name port} [fconfigure $data(socket) -sockname] break
	binary format cssisiiIIciiiii 255 $version 0x2b $data(uin) 0\
		$data(-myport) $data(-uin) [IP $addr] [IP $addr] 4\
		$data(-myport) $data(-cookie) 80 3 0
}

proc Init2 {var {incoming 0}} {
	binary format ciiiiiiii 3 10 1 $incoming 0 0 [expr $incoming*0x40001]\
		0 [expr ($incoming^1)*0x40001]
}

proc direct::Ack {} { binary format i 1 }

# Check if message is acknowledged. If not, send event Timeout
proc direct::CheckAck {var seq} {
	upvar 1 ${var}-sent sent
	if {![info exists sent($seq)]} return
	foreach {type message id} $sent($seq) break
	unset sent($seq)
	event $var Timeout $type $message $id
}

proc direct::message {seq enc text} {
	Message 2030 $seq 1 0 20 $enc $text [binary format ii 0 0xFFFFFF]
}

proc direct::AckMessage {seq type status flags msg ext} {
	Message 2010 $seq $type $status $flags "" $msg $ext
}

proc direct::Message {cmd seq type status flags enc msg {ext ""}} {
	variable textkey
	variable base

	if {$enc!=""} { set msg [encoding convertto $enc $msg] }
	set chunk [binary format is 0 $cmd][::icq::MessageAdv $type\
		$status $flags $seq $msg $ext $enc]
	binary scan $chunk c* bytes
	set M1 [expr {(int(rand()*([string length $chunk]-16))&0xFF)|0x10}]
	set X1 [expr {([lindex $bytes $M1]+0x100)%0x100}]
	set X2 [expr {int(rand()*[llength $textkey])%220}]
	set X3 [expr {([lindex $textkey $X2]+0x100)%0x100}]
	set B1 [B1 $cmd 14]
	set check [expr {(($M1<<24) + ($X1<<16) + ($X2<<8) + $X3)^$B1}]
	set key [expr $base*[string length $chunk]+$check]
	set result [Xor $key $chunk]
	return [binary format ci 2 $check][string range $result 4 end]
}

proc direct::incoming:Message {var packet sock} {
	variable base
	binary scan $packet i check
	set size [string length $packet]
	set key [expr $base*[string length $packet]+$check]
	
	set packet [Xor $key $packet]
	
	binary scan $packet @4sssiiia* cmd test seq _ _ _ rest
	# Integrity check
	if {[set res [Check [B1 $cmd $test] $check $packet]]} {
		event $var Error "Error in packet: $res"
		return
	}
	binary scan $rest ssssa* type status flags len msg
	binary scan $msg a${len}a* msg ext
	event $var Log {debug message} [format "type %x status %x flags %x len=$len" $type $status $flags]
	# Make sequence unsigned
	set seq [expr {($seq+0x10000)&0xFFFF}]
	if {$cmd==2010} {
		IncomingAcknowledgement $var $seq $msg
	} else {
		foreach {maptype message} [::icq::FormatMessageAdv\
			$type $msg $ext [set ${var}(-encoding)]] break
		if {$maptype=="autorequest"} {
			upvar #0 $var data
			if {[info exists data(-auto-$message)]} {
				set msg $data(-auto-$message)
			} else { set msg none }
			event $var Log {debug message} "acknowledge auto $message from $var with <$msg>"
		} elseif {$maptype!="service"} { 
			event $var Incoming $maptype $message 
		}
		send $var [AckMessage $seq $type 0 $flags $msg $ext]
	}	
}

proc direct::IncomingAcknowledgement {var seq msg} {
	upvar #0 ${var}-sent sent 
	if {[info exists sent($seq)]} {
		event $var ACK client [lindex $sent($seq) end]
		unset sent($seq)
	}
}

proc direct::Xor {key chunk} {
	variable textkey
	set limit [expr {(([string length $chunk]+15)/16)*4}]
	set first [string range $chunk 0 [expr $limit-1]]
	set len [expr [string length $first]-1]
	append first "\0\0\0"
	binary scan $first i* dwords 
	set i 0
	set res [list]
	foreach x $dwords {
		lappend res [expr $x^($key+[lindex $textkey $i])]
		set i [expr {($i+4)%0x100}]
	}
	set _ [string range [binary format i* $res] 0 $len]
	append _ [string range $chunk $limit end]
}

proc direct::Check {B1 check message} {
	variable textkey
	binary scan [binary format I [expr $B1^$check]] c4 l
	foreach x {M1 X1 X2 X3} y $l {set $x [expr ($y+0x100)%0x100]}
	if {$M1<10 || $M1>[string length $message]} { return 1 }
	if {$X2>220} { return 2 }
	binary scan $message H* hex
	binary scan $message @${M1}c x1
	set x1 [expr {($x1+0x100)%0x100}]
	if {$x1!=$X1} { 
		puts [format "x1=%d,%x, X1=%d,%x" $x1 $x1 $X1 $X1]
		return 3 
	}
	if {[lindex $textkey $X2]!=$X3} { return 4 }
	return 0
}

proc B1 {a b} {
	set half [expr {(($a&0xFF)<<8)+($b&0xFF)}]
	expr { (($half<<16) + $half)^0x00FF00FF }
}

proc direct::server {port args} {
	if {[catch {
		set sock [socket -server [nc SpawnCommand] $port] 
	    } reason]} { return -code error "Can not start DC server: $reason" }
	foreach {_ _ port} [fconfigure $sock -sockname] break
	set cmd server-$port
	array set data::${cmd} [list port $port\
		cookie [expr {int(0x7FFFFFF*rand())}] uin server]
	_command $cmd server $args
}

proc direct::peer {uin args} {
	set var peer-$uin
	array set data::$var [list state off queue {} seq 65535 header 1\
		len 2 uin $uin -uin 0 -encoding [encoding system] -myport 0\
		-timeout 20000]
	_command $var peer $args
}

proc direct::_command {var class options} {
	configure data::$var $class $options
	set ns [namespace current]
	interp alias {} $var {} ${ns}::dispatch ${ns}::data::$var $class
	set var
}

proc direct::configure {var class options} {
	variable ${class}_options
	if {![info exists ${class}_options]} { return "Unknown class $class"}
	set valid [set ${class}_options]
	upvar 1 $var data
	if {[llength $options]==1} {
		set key [lindex $options 0]
		if {[lsearch -exact $valid $key]==-1} {
			return -code error "Unknown option $key. Valid options are: $valid"
		} else { return $data($key) }
	}
	foreach {key val} $options {
		if {[lsearch -exact $valid $key]==-1} {
			return -code error "Unknown option $key. Valid options are: $valid"
		}
		set data($key) $val
	}
}

proc direct::dispatch {cmd class method args} {
	if {$method=="configure"} { return [configure $cmd $class $args] }
	if {![llength [info commands $class:$method]]} {
		return -code error "Unknown $class method $method" 
	}
	eval [list $class:$method] $cmd $args
}

